perm filename SLRSCL.OLD[NEW,LCS] blob
sn#517363 filedate 1980-06-21 generic text, type T, neo UTF8
00100 C**SUBRS. SLUR, (JUGGLE), (LOOP), (PLTSRT), (LINES), (HOMER),
00200 C SCL,(FORMAT), IBLANK, BMX, ACSHFT, SETUP, TYPE, SETLET, BEAMX
00300
00400 SUBROUTINE SLUR
00500 IMPLICIT INTEGER(A-Q,T-Z)
00600 COMMON/SLR/ SLURX(32)
00700 REAL CENTR
00800 COMMON /XRN/RN(1) /PLTR/PLT,RHT,RDIS
00900 COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
01000 1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
01100 1 J5,J6,J7,J8,J9,J10,J11,JQ(8),RJ
01200 COMMON/PTR/PWDS(1) /STF/RSTFAC(0/7),RSTJ2
01300 1 /LIMIT/LIMIT,ITEM,L,I,IX /ALF/INP,SLURY(72)
01400 CC DATA RSLUR/22.0/
01500 CF DATA RZZ/2.8/
01600 C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
01700
01800 CCC IF(JA.NE.12)GO TO 2
01900 CF RA=5.96*RSTJ2*R5
02000 CF L=3
02100 CF J8=J8*RDIS
02200 CF IF(J7.LE.J6)J7=J7+360
02300 CF KQ=6
02400 CF IF(PLT)KQ=1
02500 CF10 DO 3 K=J6,J7,KQ
02600 CF R=K
02700 CF CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
02800 CF3 L=2
02900 CF J8=J8-1
03000 CF IF(J8)RETURN
03100 CF RA=RA+1/RDIS
03200 CF L=3
03300 CF GO TO 10
03400 CJA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
03500 CCC CALL CIRCLE
03600 CCC RETURN
03700
03800 C*** SLURS *** 5, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
03900 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
04000 C P9=NUM IN BRACKET(IF NON-ZERO)
04100 2 IF(J8.GE.7)CALL BRKSLR
04200 C J8=7=SLUR WITH VERT. BRKTS. =8=BRKT ON LEFT ONLY. =9=ON RIGHT ONLY.
04300 J10=1
04400 J4=-1
04500 J5=1
04600 C ↑↑↑↑ FOR DPY ONLY (32 SEGS ARE USED)
04700 TWICE=-1
04800 IF(R3.GT.-1000)GO TO 2100
04900 R=-R3-1000
05000 L=R
05100 R=-(R3+1000+R)
05200 R3=RN(PWDS(L)+4)+R
05300 2100 IF(R6.GT.-1000)GO TO 21
05400 R=-R6-1000
05500 L=R
05600 R=-(R6+1000+R)
05700 R6=RN(PWDS(L)+4)+R
05800 COCT IF(R6)R6=202
05900 C R6=NEG. IS FOR PAGE-LAYOUT PROG. TELLS WHICH NOTE TO SLUR TO.
06000 21 RST7=RSTJ2*7.
06100 RJ=ABS(R7)
06200 C R7+100=LEFT HALF SLUR, +200=RIGHT HALF, +300=REVERSE DIRECTION.
06300 IF(RJ.LT.100)RJ=-1
06400 R7=AMOD(R7,100.0)
06500 IF(RJ.LT.300)GO TO 20
06600 RJ=0
06700 CC*** NOT YET! R5=R5-(2*R7)
06800 C R5 THINKS THE SLUR ISN'T REVERSED.
06900 C TO USE THIS ADD R6=SQRT((R5-R4)**2+(R6-R3)**2)+R3(WITH FACTORS)
07000 20 RQQ=R5-R4
07100 IF(R6.GT.1000)CALL RNOTE(R6)
07200 GO TO (5,6,7),J8+4
07300 GO TO 4
07400 CC5 R=32
07500 5 R=30
07600 C AFTER DOTTED NOTE
07700 GO TO 8
07800 6 R=22
07900 CC6 R=RSLUR
08000 C BETWEEN NOTES
08100 CC8 RX=-1.3
08200 8 RX=-0.75
08300 GO TO 9
08400 7 R=7
08500 RX=RSTJ2
08600 9 CALL RJBX(R)
08700 R6=R6+RX
08800 4 RXX=RHORZ(R6)-R3
08900 RTILT=RQQ*RST7
09000 80 RX=SQRT(RXX**2+RTILT**2)
09100 IF(J8.NE.-1)GO TO 1
09200 IF(RQQ.GT.8)RQQ=8
09300 IF(RQQ.LT.-8)RQQ=-8
09400 RQQ=RQQ*RSTFAC(J2)*1.0
09500 IF(R7)RQQ=-RQQ
09600 R3=R3-RQQ
09700 C MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
09800 1 R=CENTR
09900 IF(J8.GT.0)GO TO 180
10000 C JUMP FOR BRACKETS
10100 L=32
10200 CALL SLOOP
10300
10400 CF RB=RX/71.
10500 CF DO 81 K=0,71
10600 CF81 SLURX(K+1)=RB*(K)+R3
10700 CF RA=R7*RST7
10800 CF41 IF(R9.EQ.0)R9=RZZ
10900 CF R=R+RA
11000 CF L=0
11100 CF DO 40 K=36,1,-1
11200 CF L=L+1
11300 CF RW=R-RA*(K/36.)**R9
11400 CF SLURY(L)=RW
11500 CF40 SLURY(73-L)=RW
11600 CF L=72
11700
11800 CF89 IF(RTILT.EQ.0)GO TO 87
11900 CF RW=ATAN2(RTILT,RXX)
12000 CF RA=SIN(RW)
12100 CF RB=COS(RW)
12200 CF RZ=SLURX(1)
12300 CF RW=SLURY(1)
12400 CF DO 83 K=1,L
12500 CF R=SLURX(K)-RZ
12600 CF RXX=SLURY(K)-RW
12700 CF SLURX(K)=RB*R-RA*RXX+RZ
12800 CF83 SLURY(K)=RB*RXX+RA*R+RW
12900
13000 87 IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
13100 J6=J10
13200 J7=L
13300 IF(J4.NE.0)GO TO 22
13400 CALL EXCH(J6,J7)
13500 J5=-1
13600
13700 22 IF(J11.NE.0)J11=3
13800 CALL SLRS
13900
14000 C22 IF(J11.EQ.0)GO TO 122
14100 CC IF(MOD(J11,2).EQ.0)J11=J11+1
14200 C MAKE SURE WE HAVE AN ODD NUMBER OF SEGMENTS FOR DASHES.
14300 C J11=3
14400 C KD=2
14500 C KT=0
14600 C KA=1
14700 C THIS WILL MAKE DASHED SLURS J11 HAS DASH SIZE.
14800 C DO 188 K=J6,J7,J5
14900 C KT=KT+1
15000 C IF(KT.LT.J11)GO TO 188
15100 C KT=0
15200 C KD=KD+KA
15300 C KA=-KA
15400 C BLANK-DASH FLIP-FLOP
15500 C188 CALL LINES(SLURX(K),SLURY(K),KD)
15600 C GO TO 123
15700
15800 C122 DO 88 K=J6,J7,J5
15900 C88 CALL LINES(SLURX(K),SLURY(K),2)
16000 123 IF(J5.GT.1)CALL LINES(SLURX(L),SLURY(L),2)
16100 C DISPLAY END POINT OF SLUR
16200 IF(TWICE)RETURN
16300 TWICE=TWICE-1
16400 GO TO 182
16500 180 RW=R+R7*RST7
16600 TWICE=-1
16700 CC KQ=1
16800 J5=1
16900 RX=RX+R3
17000 CC RA=(R5-R4)*RST7
17100 IF(J9.EQ.0)GO TO 181
17200 RZ=RTILT/(RX-R3)
17300 TWICE=2
17400 CC RZ=RX-R3
17500 RXX=RX
17600 RWID=(R3+RXX)/2.
17700 182 IF(TWICE.EQ.1)GO TO 183
17800 C DOES LEFT SIDE FIRST.
17900 IF(TWICE.EQ.0)GO TO 184
18000 C LAST IS NUMBER.
18100 J8=2
18200 RC=RSTJ2*13.
18300 RX=RWID-RC
18400 RWW=RTILT
18500 185 RTILT=RZ*(RX-R3)
18600
18700 C PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
18800
18900 GO TO 181
19000 183 J8=3
19100 RX=RXX
19200 RTILT=RWW
19300 RXX=R3
19400 R3=RWID+RC
19500 RXX=RZ*(R3-RXX)
19600 R=R+RXX
19700 RW=RW+RXX
19800 GO TO 185
19900
20000 181 SLURX(1)=R3
20100 SLURY(1)=R
20200 SLURX(2)=R3
20300 SLURY(2)=RW
20400 SLURX(3)=RX
20500 SLURY(3)=RW+RTILT
20600 SLURX(4)=RX
20700 SLURY(4)=R+RTILT
20800 L=4
20900 IF(J8.EQ.2)L=3
21000 IF(J8.EQ.3)J10=2
21100 CC TWICE=-1
21200 GO TO 87
21300 184 J3=RWID
21400 C PUT IN VERT. POS. WHEN SLOPE!
21500 R4=RQQ/2.+R4+R7-1.
21600 R6=0.875
21700 C SIZE(R6) IS 0.875 R7=1 IS FOR ITALICS
21800 R7=1
21900 R8=0
22000 CALL MAKNUM(R9)
22100 END
22200
22300 SUBROUTINE SCL
22400 C SETS UP SCALING MARKERS.
22500 COMMON /STF/RSTFAC(0/7),RSTJ2 /RINP/SU(900)
22600 COMMON R2,JA,CT,J2,R3,R4,R5,RJQ(17),J3,J4,J5,J6,J(16)
22700 1 /POSI/STFF(0/7),J102,POS
22800 J2=R2
22900 IF(J2.NE.99)GO TO 1008
23000 CALL HYDPOG(2)
23100 RETURN
23200 1008 J5=0
23300 J6=0
23400 RSTJ2=RSTFAC(J2)
23500 C SETS UP SCALE LINES.
23600 J4=200
23700 IF(R3.NE.0)J4=400
23800 C PUTS SCALE TO 400
23900 R2=STFF(J2)+60.*RSTJ2
24000 RJ=R2+60.
24100 CALL DPYSET(2,SU,700)
24200 CALL DPYBRT(3)
24300 POS=RJ+40.
24400 RSTJ2=1.
24500 DO 1002 MX=10,J4,10
24600 RA=RHORZ(FLOAT(MX))
24700 R3=RA-58
24800 IF(MX.GT.10)CALL PNUM
24900 CC1005 IF(R5.NE.0)GO TO 1007
25000 C JUMP FOR STAFF NUMBERS
25100 CALL LINX(RA,R2,RA,RJ)
25200 J5=J5+1
25300 1002 IF(J5.EQ.10)J5=0
25400 CALL LINES(-596.0,RJ,2)
25500 CALL LINES(-596.0,R2,2)
25600 R6=1.5
25700 C NEXT SETS UP STAFF NUMBERS TO FAR RIGHT(OUT OF WAY OF TYPING.)
25800 R3=615.
25900 DO 1007 K=0,7
26000 POS=STFF(K)+40.
26100 J5=IABS(K)
26200 CALL PNUM
26300 1007 CONTINUE
26400 CC CALL DPYDO(2)
26500 CALL DPYOUT(2)
26600 CALL SETPOG(1)
26700 END
26800
26900 FUNCTION IBLANK(IS,N)
27000 COMMON /XRN/RN(2000)
27100 IBLANK=0
27200 IF(AMOD(RN(IS+N),100.0).EQ.99.0)IBLANK=-1
27300 END
27400
27500 SUBROUTINE BMX(RA)
27600 C RA=NUMB. OF TAILS
27700 C VQ HOLDS TEMPORARY INFO RE. MULTIPLE BEAMS.
27800 COMMON E,F,G,H,RJQ(34),RB,VQX,JB,B,JV,JW /XRN/RN(1)
27900 1 /RINP/R(10,85),VQ(100) /STF/RSTFAC(0/7),RSTJ2
28000 1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND /RNW/RNW
28100 1/LIMIT/LIMIT,ITEM,LL,IS,IX /SC/J,L,MK
28200 1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,IXX,ISEMI,IQT
28300 1 ,VX(50),IAMP,K,KN,M,MODE,IBLA
28400 1 /SCX/JALPHA(30),JX,U,JZ,IRHY,JD,KA,KB,IZ
28500 M=IS-12
28600 RX7=RN(7+M)
28700 C ORIGINAL STEM DIR. AND NUM. OF BEAMS INFO.
28800 DO 1 L=KN,K
28900 B=R(7,L)
29000 JB=B/10
29100 B=B-JB*10
29200 C??? B=AMOD(R(7,L),10.0)
29300 IF(R(8,L).EQ.1000.)B=0
29400 C AVOIDS GRACE NOTES AND NON-NOTES
29500 IF(R(1,L).NE.1)B=0
29600 1 VQ(L)=B
29700 VQ(K+1)=0
29800 C CLEARS IT FOR ROUTINE AT '3'
29900 JB=KN
30000 RX8=0
30100 JBX=0
30200 C THE ABOVE 2 ARE FOR NEW COMPOSITE BEAM FEATURE 5/78
30300
30400 6 DIS=0
30500 RB9=0
30600 DO 2 L=JB,K
30700 IF(VQ(L).LE.RA)GO TO 2
30800 C SKIP IF EQ. TO PRESENT BEAM
30900 RB=VQ(L)
31000 LL=L
31100 4 DO 11 JD=LL,K
31200 VQX = VQ(JD)
31300 IF(VQX.GE.RB)GO TO 20
31400 IF(VQX.EQ.0)GO TO 11
31500 C VQX=0 ON NON-STEM NOTES OF CHORDS. (HENCE NO TAILS)
31600 21 B=10.
31700 IF(LL.GT.KN)GO TO 13
31800 GO TO 16
31900 20 JV=JD
32000 IF(VQX.GT.RB)GO TO 21
32100 11 JW=JD
32200 B=20
32300 C FINDS NEED FOR BEAM TO LEFT
32400 16 B=B+RA
32500 IF(JBX)GO TO 50
32600 C FOR NEW COMPOSITE BEAM FEATURE 5/78
32700 JE=RN(7+M)/10.
32800 RN(7+M)=JE*10.+RA
32900 GO TO 51
33000 50 DO 5 JE=1,6
33100 5 RN(JE+IS)=RN(JE+M)
33200 RN(7+IS)=RX7+RB-RA*2.
33300 C ADDS RIGHT NUM. OF BEAMS
33400 51 IF(LL.NE.JV)GO TO 10
33500 IF(LL.EQ.KN)GO TO 377
33600 IF(LL.NE.K)GO TO 10
33700 377 B=-B
33800 C PARTIAL, UNATTACHED BEAM IS PLACED AUTOMATICALLY IN ITMSUB.
33900 GO TO 8
34000 13 IF(JV.GT.LL)GO TO 14
34100 IF(R(7,LL+1).LT.10)GO TO 15
34200 C NEXT FOR DOT ON FOLLOWING NOTE.
34300 DIS=10.
34400 GO TO 19
34500 15 DIS=20.
34600 C SHORT INNER BEAM TO LEFT OF STEM
34700 19 B=-RA
34800 GO TO 16
34900 14 DIS=30
35000 C LONG INNER BEAM
35100 JV=-JV
35200 GO TO 16
35300
35400 C PARTIAL BEAM IS ON RIGHT(+) OR LEFT(-). RBM IS LENGTH.
35500 10 IF(LL.EQ.KN)GO TO 22
35600 IF(JV.GE.0)GO TO 17
35700 B=R(3,LL)
35800 JV=-JV
35900 LL=JV
36000 22 IF(VQ(JW+1).GT.VQ(JW))GO TO 17
36100 VQ(JW)=VQ(JW+1)
36200 JW=JW-1
36300 17 IF(LL.NE.JB)GO TO 18
36400 IF(B.LT.20.)LL=JV
36500 C PUTS BEAMS IN RIGHT PLACE.
36600 18 RC=R(10,LL)
36700 IF(RC.EQ.0)GO TO 23
36800 RB=RNW*RSTJ2
36900 IF(ABS(R(4,LL)).GE.100)RB=RB*.6
37000 C GET WIDTH OF NOTE(RNW) FOR DISPLACEMENT
37100 IF(RC.EQ.2)RB=-RB
37200 RC=RB
37300 23 RB9=RC+R(3,LL)
37400 C THIS WILL BE POS.3
37500 DIS=RA+DIS
37600 C DISPLACES
37700 GO TO 8
37800 2 CONTINUE
37900 RETURN
38000 8 JB=JW+1
38100 C FINDS SIDE (L,R) FOR PARTIAL BEAM
38200 C FOR NEW DISPLACEMENT
38300 RN(IS+11)=-1
38400 IF(RB9+DIS.EQ.0)GO TO 31
38500 IF(DIS.LT.10)GO TO 32
38600 IF(DIS.LT.30)GO TO 33
38700 C INNER PARTIAL BEAM IS NEXT
38800 DIS=DIS-30
38900 GO TO 31
39000 32 IF(B.GE.20)GO TO 12
39100 DIS=B-10
39200 B=-1
39300 C -1 PICKS UP POS OF P3
39400 GO TO 31
39500 12 DIS=B-20
39600 B=RB9
39700 RB9=-1
39800 C -1 IN P9 WILL PICK UP POS OF P6
39900 C INNER BEAM ATTACHED TO LFT SIDE.
40000 GO TO 31
40100 33 B=-DIS
40200 DIS=0
40300 31 L=IS
40400 IF(JBX)GO TO 53
40500 L=M
40600 DIS=(RB-RA)*100.+1.
40700 53 IF(RX8.GT.1.)GO TO 52
40800 IF(RB9.NE.0)GO TO 52
40900 IF(RX8.NE.0)GO TO 54
41000 RX8=B
41100 GO TO 52
41200 54 RN(8+M)=-30
41300 C TWO UNATTACHED BEAMS, LEFT AND RIGHT
41400 RX8=1
41500 GO TO 55
41600 52 RN(8+L)=B
41700 RN(9+L)=RB9
41800 RN(10+L)=DIS
41900 IF(JBX)CALL UPDATE(9)
42000 C ADDED ANOTHER ITEM (PART. BEAM)
42100 JBX=-1
42200 JA=0
42300 55 IF(JB.LE.K)GO TO 6
42400 END
42500
42600 SUBROUTINE ACSHFT(RX)
42700 COMMON /XRN/RN(1) /STF/RSTFAC(0/7),RSTJ2
42800 1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
42900 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
43000 1,DBST,NFLG,IXX,ISEMI,IQT,F(50),IAMP,K,KN,M,MODE,IBLA
43100 1 /RINP/R(10,85),VQ(100)
43200 EQUIVALENCE (A,F(1)),(B,F(2)),(X,F(4)),
43300 1(Y,F(5)),(Z,F(6)),(JD,F(7)),(RN1,F(8)),(RH,F(9))
43400 Z=0
43500 L=K-1
43600 M=L-ABS(RX)
43700 JD=1
43800 RN1=99
43900 Y=-.23
44000 IF(RX.LT.0)GO TO 1
44100 L=M
44200 M=K-1
44300 JD=-1
44400 1 DO 2 N=M,L,JD
44500 C DOES IT HAVE AN ACCID?
44600 IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
44700 A=0
44800 B=0
44900 IF(N.LT.L)A=R(6,N+1)
45000 IF(N.GT.M)B=R(6,N-1)
45100 IF(RN1.NE.99)GO TO 3
45200 C IS THIS THE FIRST ACCID?
45300 RN1=R(4,N)
45400 GO TO 6
45500 3 RH=R(4,N)
45600 IF(ABS(RH-RN1).LT.5)GO TO 4
45700 RN1=RH
45800 IF(Y.GT.0)Z=Z+.04
45900 C STOPS OCT., ETC. ACCIS BEING MOVED TO LEFT.
46000 Y=-.23+Z
46100 6 IF(A.EQ.20)GO TO 477
46200 IF(B.NE.20)GO TO 4
46300 477 Y=Z
46400 4 X=0
46500 IF(R(6,N).EQ.20)X=-.24
46600 IF(R(6,N).EQ.10)X=.24
46700 Y=Y+.23
46800 IF(X+Y.LT.1)GO TO 7
46900 RN1=RH
47000 Z=Z+.04
47100 Y=0
47200 IF(A.EQ.20)GO TO 677
47300 IF(B.NE.20)GO TO 577
47400 677 Y=.23
47500 C SO Y DOESN'T GET >1.
47600 577 Y=Y+Z
47700 7 X=X+Y
47800 IF(ABS(X-.04).LT..01)X=0
47900 IF(X.GE.0)GO TO 5
48000 Y=.23+Z
48100 X=Z
48200 5 R(5,N)=R(5,N)+X*RSTFAC(IFIX(STAFF))
48300 C SPACING OF ACCI. DEPENDS ON STAFF SIZE FACTOR AT THIS POINT
48400 2 CONTINUE
48500 END
48600
48700 C SETUP ALLOWS SETING UP RHYTHMS ON DESIGNATED STAFF FOR SPACING ALL OTHERS.
48800 SUBROUTINE SETUP
48900 INTEGER PWDS
49000 COMMON /SCM/V(78),IV,LCNT,STAFF,LIST(200),REND
49100 1 /PTR/PWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX
49200 1 /DPY/ST(4000),MEDIT,GO /XRN/RN(1)
49300 1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,
49400 1 ENDP,RA,RDD,ITB,POSB
49500 DIMENSION RPOS(2,100)
49600 EQUIVALENCE (RPOS,ST(3400))
49700
49800 C RHYTHMIC VALUES ARE SAVED IN P9 OF NOTES AND P7 OF RESTS.
49900 STUP=-1
50000 C THIS SENDS INFO TO SUBR. NOTES
50100 IF(SET4.GT.7)RETURN
50200 C **** BE SURE SETUP STAFF HAS SPACE VALUES IN NOTES AND RESTS!!!
50300 IF(ITEM.EQ.0)RETURN
50400 JX=0
50500 RA=0
50600 DO 9534 K=1,ITEM
50700 L=PWDS(K)
50800 IF(RN(L+2).NE.SET4)GO TO 9534
50900 RD=RN(L+1)
51000 IF(RD.LT.5)GO TO 5
51100 IF(RD.LT.17)GO TO 9534
51200 5 IF(RD.GT.2)GO TO 6
51300 RC=7
51400 IF(RD.EQ.2)RC=5
51500 IF(RN(L).LT.RC)GO TO 9534
51600 M=9
51700 IF(RD.EQ.2)M=7
51800 RC=RN(L+M)
51900 IF(RC.EQ.0)GO TO 9534
52000 C FOR OTHER NOTES ON SPACING STAFF.
52100 IF(RC.EQ.4./88.)GO TO 9534
52200 C THESE FOR GRACE NOTES (1/88 NOTES)
52300 GO TO 7
52400 C SKIPS 'OTHER' CHORD TONES (I.E. P9=0 IN A NOTE)
52500 6 IF(RD.NE.3)GO TO 8
52600 IF(RN(L).LT.3)GO TO 7
52700 RC=RN(L+5)
52800 IF(RC.GE.100)GO TO 7
52900 IF(RC.GT.3)GO TO 9534
53000 C SKIPS IF NOT A REAL CLEF (+100=MINI CLEF)
53100 GO TO 7
53200 8 IF(RD.NE.4)GO TO 10
53300 IF(RN(L).GT.2)GO TO 9534
53400 C SKIPS IF NOT BARLINE (I.E. ONLY 4 PARAMS)
53500 10 IF(RD.NE.2)GO TO 7
53600 IF(RN(L).LT.5)GO TO 9534
53700 IF(RN(L+7).EQ.0)GO TO 9534
53800 7 JX=JX+1
53900 RPOS(1,JX)=RN(L+3)
54000 IF(RD.GT.2)GO TO 3
54100 C JUMP WHEN TIME VALUES ARE IN P8
54200 C FOR VALUES AUTOMATICALLY SET. ALLOWS NON-DUPLE UNITS IN SETUP
54300 277 RA=RA+RC
54400 C SUM OF RHYTHS
54500 GO TO 77
54600 3 RC=-RD
54700 77 RPOS(2,JX)=RC
54800 C RC IS RHYTHMIC VALUE OF NOTE.
54900 9534 CONTINUE
55000 C NEXT PUTS ITEMS IN PROPER ORDER IF THEY WEREN'T ALREADY
55100 C*** 2ND NOTE OF DBL STOP CAN'T!! HAVE RHYTH. VALUE *******
55200 IF(RA.EQ.0)RETURN
55300 C RA=0 MEANS DIDN'T FIND RHYTHMS ON SPACING STAFF.
55400
55500 CALL SORT2(RPOS,JX)
55600 ENDP=200.
55700 IF(RPOS(2,JX))ENDP=RPOS(1,JX)
55800 DO 1 L=1,JX
55900 1 IF(RPOS(2,L).GT.0)GO TO 4
56000 4 RD=RPOS(1,L)
56100 RB=ENDP-RD
56200 C TOTAL SPACE FROM 1ST NOTE TO END OF LINE
56300 RC=RPOS(2,L)
56400 RPOS(2,L)=RD
56500 C REAL AND AVERAGED POSITIONS OF 1ST NOTE ARE THE SAME.
56600 DO 2 K=L+1,JX
56700 RE=RPOS(2,K)
56800 IF(RE)GO TO 2
56900 RD=RC/RA*RB+RD
57000 RC=RE
57100 RPOS(2,K)=RD
57200 2 CONTINUE
57300 C 1,K=REAL POS. 2,K=AVERAGED POS.
57400 C IN RHYTH: POS=(P1-AVG2)*(RL2-RL1)/(AVG2-AVG1)+RL1
57500 JX=JX+1
57600 RPOS(1,JX)=ENDP
57700 RPOS(2,JX)=ENDP
57800 STUP=0
57900 C THIS FOR NOTES AND RHYTH
58000 END
58100
58200 SUBROUTINE TYPE
58300 COMMON/ALF/INP(72),ML /IDEV/IDEV /MKX/KSLA,ISEMI,LESS,IGT
58400 IF(IDEV.NE.5)GO TO 2
58500 1 CALL TYPSTR('TYPE --')
58600 CALL TYPCRL
58700 2 READ(IDEV,2114,END=167)INP
58800 IF(INP(1).EQ.LESS)GO TO 167
58900 IF(INP(1).NE.IGT)RETURN
59000 IDEV=1
59100 GO TO 2
59200 167 IDEV=5
59300 GO TO 1
59400 2114 FORMAT(72A1)
59500 C FOR 'SCORE' INPUT
59600 END
59700
59800 SUBROUTINE SETLET
59900 COMMON/SCM/V(76),RR4,NN,Y,LCNT,STAFF,JLIST(200),REND
60000 C NOTE DIFFERENCE IN V ARRAY LNGTH 76+RR4+NN
60100 COMMON /MKX/KSLA,ISEMI,LESS,IGT
60200 COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,JR
60300 1 /PTR/KWDS(1) /IDEV/IDEV /DL/IX22
60400 COMMON/FRMT/F78F(1),FA1(1),FA5(1),KK /ALF/INP(72),ML
60500 COMMON/SCN/LEL,LR,LU,LD,SLA,LE,LC,LS,LF,LA,LI,LW
60600 1 /POSI/STFP(0/7),J102,POS /LIMIT/LIMIT,ITEM,L,I,IX /XRN/RN(1)
60700 1 /RINP/RPOS(2,450) /DPY/ST(4000),MEDIT,IGO
60800 DIMENSION SU(320)
60900 EQUIVALENCE (J5,JQ(3)),(ISET,RJQ(9)),(SU(1),ST(3600))
61000 X=0
61100 IF(IX22.EQ.0)GO TO 10
61200 C NEXT FOR 'CP n' TO CENTER ITEM BY NOTE POSITION
61300 X=R2
61400 R2=RN(KWDS(IX22)+2)
61500 10 KK=L
61600 C L=NUMBER OF ITEMS TYPED +1
61700 M=1
61800 IF(R4.EQ.0)KK=0
61900 C =0 ALWAYS WANTS PAIRS OF NUMS.
62000 RR4=R4
62100 C GIVEN VERTICAL POS.
62200 R4=20
62300 RPOS(1,1)=0
62400 DO 1 K=1,ITEM
62500 IF(FINDIT(K))GO TO 1
62600 C SKIPS NON-NOTES AND WRONG STAFF
62700 M=M+1
62800 RPOS(1,M)=RN(L+3)
62900 1 CONTINUE
63000 IF(M.EQ.1)RETURN
63100 C M=1 MEANS NO NOTES ON THIS LINE
63200 CALL DPYSET(3,SU,320)
63300 CALL DPYBRT(6)
63400 POS=STFP(J2)
63500 J5=1
63600 CALL SORT2(RPOS,M)
63700 K=2
63800 JSET=ISET
63900 22 IF(IFIX(RPOS(1,K)*100.).NE.IFIX(RPOS(1,K-1)*100.))GO TO 2
64000 C ROUNDS OFF POSITION TO 2 DECI. PLACES
64100 M=M-1
64200 DO 20 J=K,M
64300 20 RPOS(1,J)=RPOS(1,J+1)
64400 C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
64500 IF(M.LT.K)K=M
64600 GO TO 22
64700 2 K=K+1
64800 IF(K.LT.M)GO TO 22
64900 DO 4 K=2,M
65000 R3=RHORZ(RPOS(1,K))
65100 CALL PNUM
65200 J5=J5+1
65300 4 IF(J5.EQ.10)J5=0
65400 CALL DPYOUT(3)
65500 CC CALL DPYDO(3)
65600 CALL SETPOG(1)
65700 RPOS(1,M+1)=200
65800 NN2=1
65900 J=1
66000 IF(IX22.EQ.0)GO TO 11
66100 R3=0
66200 JA=3
66300 R4=0
66400 IF(X.NE.0)GO TO 12
66500 CALL TYPSTR(' POS = ')
66600 GO TO 1301
66700 12 X=X+1.
66800 GO TO 3
66900 11 JJ=1
67000 C FLAG FOR ALL BLANKS AT END OF LINE
67100 30 MM=-1
67200 K=JJ
67300 300 LL=INP(K)
67400 IF(LL.NE.' ')MM=0
67500 IF(LL.EQ.KSLA)GO TO 301
67600 IF(K.GE.72)GO TO 301
67700 K=K+1
67800 GO TO 300
67900 167 IDEV=5
68000 301 IF(MM)GO TO 31
68100 IF(IDEV.EQ.1)GO TO 1301
68200 CALL TYPSTR(' POS. FOR -- ')
68300 DO 302 LL=JJ,K
68400 302 CALL TYPCHR(INP(LL),1)
68500 CALL TYPSTR(' ')
68600 1301 NN=NN2
68700 NN2=NN2+1
68800 IF(NN.GT.1)GO TO 1267
68900 READ(IDEV,F78F,END=167)V
69000 IF(V(1).NE.99.)GO TO 2267
69100 C READS 38 NUMS. 1ST TIME. NOW '99' = 1,2,3,...38 (VERT. PRESET)
69200 X=0
69300 DO 3267 LL=1,76,2
69400 X=X+1.0
69500 V(LL)=X
69600 3267 V(LL+1)=RR4
69700 5267 NN=76
69800 GO TO 31
69900 2267 IF(V(3).EQ.0)GO TO 267
70000 C NOTE NUMS CAN BE ON 1 LINE IF THERE ARE >2. (VERT. POS. MUST BE PRESET)
70100 NN=38
70200 DO 4267 LL=76,1,-2
70300 V(LL)=RR4
70400 V(LL-1)=V(NN)
70500 4267 NN=NN-1
70600 GO TO 5267
70700 1267 READ(IDEV,F78F,END=167)V(NN),V(NN2)
70800 REREAD FA1,JJ
70900 IF(JJ.EQ.LESS)GO TO 167
71000 IF(JJ.NE.IGT)GO TO 267
71100 IDEV=1
71200 GO TO 302
71300 267 IF(RR4.NE.0.AND.V(NN2).EQ.0)V(NN2)=RR4
71400 NN2=NN2+1
71500 V(NN2)=0
71600 JJ=K+1
71700 IF(K.LT.72)GO TO 30
71800
71900 31 X=V(J)+1
72000 IF(KK.NE.0)KK=NN-1
72100 DO 32 K=NN,1,-1
72200 32 IF(V(K).NE.0)GO TO 320
72300 320 IF(K.GT.KK)KK=-1
72400 C NOW PAIRS OF NUMS WILL SET INDIV. VERT. POS.; SINGLE DON'T
72500 IF(RN(ISET+1).NE.16.)GO TO 6
72600 C TRAP DASH AT FIRST OF LINE.
72700 3 K=X
72800 A=RPOS(1,K)
72900 B=RPOS(1,K+1)
73000 R2=A+(B-A)*(X-K)
73100 IF(IX22.NE.0)RETURN
73200 C GO BACK IF SETTING POSITION WITH 'CP'
73300 RN(ISET+3)=R2
73400 IF(KK.GT.0)GO TO 5
73500 C NEXT FOR PAIRS OF NUMS.
73600 RN(ISET+4)=V(J+1)
73700 J=J+2
73800 GO TO 6
73900 C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
74000 C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
74100 5 J=J+1
74200 6 ISET=ISET+RN(ISET)+3
74300 IF(ISET.GE.I)GO TO 7
74400 IF(RN(ISET).EQ.8)GO TO 6
74500 C =8 MEANS MORE LETTERS TO COME.
74600 X=V(J)+1
74700 IF(X.GT.1)GO TO 3
74800 C CAN'T PUT LETTER AT POS. 0 *********
74900 IF(IDEV.EQ.1)RETURN
75000 7 K=ITEM+1
75100 CALL TYPSTR('FIRST ITEM WAS ')
75200 CALL TYPINT(K)
75300 CALL TYPCRL
75400 C NOW CHECK FOR DASHES
75500 17 IF(RN(JSET+1).NE.4)GO TO 117
75600 RN(JSET+3)=RN(ISET+3)+1.
75700 C ASSUMES SOME CODE 16 CHAR. JUST BEFORE DASH. IX IS TOTAL NUM. OF ITEMS.
75800 CALL DASHES(IX,RN(JSET+2),RN(JSET+3))
75900 CC CALL DASHES(IX,R2,RN(JSET+3),RN(JSET+4),RN(JSET+5),RN(JSET+6))
76000 117 ISET=JSET
76100 JSET=JSET+RN(JSET)+3
76200 IF(JSET.LT.I)GO TO 17
76300 END
76400
76500 SUBROUTINE BEAMX
76600 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /RRJJ/RJJ2,RJJ(20)
76700 1 /LIMIT/LIMIT,ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
76800 EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
76900 1 (R6,RJQ(4)),(J10,JQ(8)),(J6,JQ(4)),(R4,RJQ(2)),(R7,RJQ(5))
77000 1,(R3,RJQ(1)),(J8,JQ(6)),(J7,JQ(5))
77100 1,(R11,RJQ(9)),(R10,RJQ(8)),(R8,RJQ(6)),(RJ3,RJJ(1))
77200 1,(R9,RJQ(7)),(J9,JQ(7))
77300
77400 IF(J10.GE.100)GO TO 6
77500 CALL BMSTF
77600 RETURN
77700 6 JZ=-2
77800 JX8=R8
77900 IF(JX8.GE.-1)GO TO 16
78000 JX8=R8/10.0
78100 JX8=JX8*10
78200 C MAKE SURE LAST DIGIT IS ZERO
78300 R8=JX8
78400 16 RR8=R8
78500 R8=0
78600 RR9=R9
78700 R9=0
78800 RR6=R6
78900 RR3=R3
79000 RR4=R4
79100 RR5=R5
79200 RSTJ=RSTJ2
79300 J=10*(J7/10)
79400 C J=STEM DIR. (10 OR 20)
79500 JJ=J10/100
79600 JJ10=J10-JJ*100
79700 C IF 3RD DIGIT OF P10 = 0, THEN TWO SECONDARY BEAM GROUPS ARE MADE.
79800 C THEN P8 AND P9 ARE THE LIMITS OF THE GAP BETWEEN THE SECONDARY GROUPS.
79900
80000 C IF 3RD DIGIT OF P10 = 1, THEN SINGLE SECONDARY BEAM GROUP IS MADE.
80100 C THEN P8 AND P9 ARE THE OUTER LIMITS OF THE SECONDARY GROUP
80200 JJ7=J7-J
80300 C J7=NUM. OF FULL BEAMS (1ST DIGIT OF P10=NUM OF ADDED BEAMS)
80400 7 J10=0
80500 5 J8=R8
80600 J9=R9
80700 R7=J7
80800 R10=J10
80900 CALL BMSTF
81000 JZ=JZ+1
81100 IF(JZ)1,2,3
81200 3 RETURN
81300
81400 1 IF(RR8.GE.0)GO TO 8
81500 IF(JX8.GE.-20)GO TO 11
81600 C UNATTACHED PARTIAL BEAM:
81700 C P8= -10=ON LEFT, -20=RIGHT, -30=BOTH
81800 RR8=RR8+10
81900 IF(JX8.EQ.-31)GO TO 11
82000 JX8=JX8-1
82100 RR9=0
82200 C ↑↑↑ A PRECAUTION
82300 JZ=JZ-2
82400 11 R8=RR8-AMOD(R7,10.0)
82500 10 R9=RR9
82600 JZ=JZ+1
82700 GO TO 4
82800 8 IF(JJ10.EQ.0)GO TO 9
82900 C NEXT MAKES ONE SECONDARY BEAM GROUP.
83000 R8=RR8
83100 GO TO 10
83200 9 R8=-1
83300 R9=RR8
83400 4 J7=J+JJ
83500 R6=RR6
83600 R3=RR3
83700 J3=RR3
83800 R4=RR4
83900 R5=RR5
84000 J10=JJ7
84100 C J10 IS DISPLACEMENT FOR OTHER BEAMS
84200 RSTJ2=RSTJ
84300 GO TO 5
84400 2 R8=RR9
84500 R9=-1
84600 GO TO 4
84700 END